home *** CD-ROM | disk | FTP | other *** search
- *-------------------------------------------------------------------------------
- *-- Program...: FIELDS.PRG
- *-- Programmer: Ken Mayer (CIS: 71333,1030)
- *-- Date......: 06/25/1992
- *-- Notes.....: These field processing routines were deemed as not as commonly
- *-- used (at least in my own Applications), and relegated to a
- *-- library file. See: README.TXT about how to use this library
- *-- file.
- *-------------------------------------------------------------------------------
-
- FUNCTION MemoPagr
- *-------------------------------------------------------------------------------
- *-- Programmer..: Martin Leon (HMAN - ATBBS/Borland BBS)
- *-- Date........: 10/28/91
- *-- Notes.......: Used to display a memo on screen, allowing user to scroll
- *-- memo at will.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: ?MemoPagr(<cMemo>,<ULRow>,<ULCol>,<BRRow>,<BRCol>)
- *-- Example.....: ?MemoPagr(MoreData,10,20,20,65)
- *-- Returns.....: .F.
- *-- Parameters..: cMemo = name of memo field
- *-- nULRow = upper left row position
- *-- nULCol = upper left column position
- *-- nBRRow = bottom right row position
- *-- nBRCol = bottom right column position
- *-------------------------------------------------------------------------------
-
- PARAMETER cMemo, nULRow, nULCol, nBRRow, nBRCol
- private cCursor, nEsc, nPgDn, nPgUp, nUp, nDn, nNumLines,nLines,nKey
- private nAtLine,nAtRow
-
- *-- set environment
- set memowidth to nBRCol - nULCol - 1
- cCursor = set( "CURSOR" )
- set cursor off
-
- *-- define a few keys
- nEsc = 27
- nPgDn = 3
- nPgUp = 18
- nUp = 5
- nDn = 24
-
- *-- determine size of window
- nNumLines = memlines(&cMemo)
- nLines = nBRRow - nULRow - 1
- *-- save the screen, so we can restore it
- save screen to sTmp
- @ nULRow+1, nULCol+1 clear to nBRRow+1, nBRCol+1
- @ nULRow+1, nULCol+1 fill to nBRRow+1, nBRCol+1 color B/N
- @ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 color RG+/B
- @ nULRow, nULCol to nBRRow, nBRCol double color RG+/B
-
- *-- deal with a blank memo ...
- if nNumLines = 0
- @ nULRow + 1, nULCol + 1 SAY ;
- "Blank Memo. Press any key to continue..." color RG+/B
- nKey = inkey(0)
- *-- reset the whole thing
- restore screen from sTmp
- release screen sTmp
- set cursor &cCursor
- RETURN .F.
- endif
-
- nAtLine = 1
- nAtRow = 1
- do while nAtLine <= nNumLines
- *-- Show one window full
- do while nAtRow <= nLines .and. nAtLine <= nNumLines
- @ nULRow+nAtRow, nULCol + 1 say ;
- mline( &cMemo, nAtLine ) color RG+/B
- nAtLine = nAtLine + 1
- nAtRow = nAtRow + 1
- enddo
-
- *-- If at last line of memo...
- if nAtLine > nNumLines
- *-- If memo is shorter than one page, put box character in
- *-- bottom left corner of box, otherwise, put an up arrow
- *-- symbol there.
- @ nBRRow - 1, nBRCol SAY ;
- iif( nNumLines <= nLines, chr(186), chr(24)) color W+/B
- do while .T.
- nKey = inkey(0)
- *-- If memo is shorter than one page, only allow Esc key
- if nNumLines <= nLines
- if nKey = nEsc
- exit
- endif
- *-- Otherwise, allow Esc or PgUp keys
- else
- if nKey = nEsc .or. nKey = nPgUp .or. nKey = nUp
- exit
- endif
- endif
- ?? chr(7)
- enddo
- if nKey = nEsc
- restore screen from sTmp
- release screen sTmp
- set cursor &cCursor
- RETURN .F.
- endif
- @ nULRow+1, nULCol+1 clear to nBRRow-1, nBRCol-1
- @ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 ;
- color RG+/B
- nAtLine = nAtLine - nAtRow - nLines + 1
- nAtLine = iif( nAtLine < 1, 1, nAtLine )
- nAtRow = 1
- loop
- endif
-
- *-- Not at end of memo yet...
- *-- If on first page, show down arrow only, otherwise show
- *-- up/down arrow on border of box.
- @ nBRRow - 1, nBRCol say ;
- iif( nAtLine - nLines = 1, chr(25), chr(18)) color W+/B
- do while .T.
- nKey = inkey(0)
- *-- If this is the first page of the memo on screen...
- if nAtLine - nLines = 1
- *-- Only honor PgDn, up cursor, and Esc keys
- if nKey = nPgDn .or. nKey = nDn .or. nKey = nEsc
- exit
- endif
- *-- otherwise honor PgUp and up cursor as well key as well
- else
- if nKey = nPgUp .or. nKey = nUp .or. nKey = nPgDn .or. ;
- nKey = nDn .or. nKey = nEsc
- exit
- endif
- endif
- ?? chr(7)
- enddo
- do case
- case nKey = nEsc
- restore screen from sTmp
- release screen sTmp
- set cursor &cCursor
- RETURN .F.
- case nKey = nPgUp .or. nKey = nUp
- @ nULRow+1, nULCol+1 clear to nBRRow-1, nBRCol-1
- @ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 ;
- color RG+/B
- nAtLine = (nAtLine - (2 * nLines))
- nAtLine = IIF( nAtLine < 1, 1, nAtLine )
- nAtRow = 1
- loop
- case nKey = nPgDn .or. nKey = nDn
- @ nULRow+1, nULCol+1 clear to nBRRow-1, nBRCol-1
- @ nULRow+1, nULCol+1 fill to nBRRow-1, nBRCol-1 ;
- color RG+/B
- nAtRow = 1
- loop
- endcase
- enddo
-
- RETURN .F.
- *-- EoF: MemoPagr()
-
- PROCEDURE ScanMemo
- *-------------------------------------------------------------------------------
- *-- Programmer..: Martin Leon (HMAN)
- *-- Date........: 02/27/1992
- *-- Notes.......: This simple procedure is used to strip hard carriage returns
- *-- out of all Memos in a database.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 04/15/1991 - original procedure.
- *-- 02/07/1992 -- Douglas P. Saine (XRED) modified to handle
- *-- passing of database name as a parameter
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: Do ScanMemo with "<cDbf>"
- *-- Example.....: Do ScanMemo with "TEST"
- *-- Returns.....: None.
- *-- Parameters..: cDbf = Name of the database to scan memos ...
- *-------------------------------------------------------------------------------
-
- parameter cDbf
- private nFields, cFieldName, nLines, nLineNum
-
- use (cDbf)
-
- scan && search database 1 record at a time ...
- nFields = 1
- *-- This loop goes through all fields in the database
- do while asc(field(nFields)) # 0
- cFieldName = field(nFields) && save current field name
- if type(cFieldName) = "M" && check to see if it's a memo
- nLines = memlines(&cFieldName) && number of lines in memo
- if nLines > 1 && if there's something there
- delete file temp.txt && kill old file if it exists
- set printer to file temp.txt && copy memo a line at a time to
- nLineNum = 1 && temp file, using ??? command.
- do while nLineNum <= nLines
- ??? mline(&cFieldName,nLineNum)
- ??? " "
- nLineNum = nLineNum + 1
- enddo
- close printer
- set printer to
- append memo &cFieldName from temp.txt overwrite
- endif && nLines > 1
- endif && type(cFieldName) = "M"
- nFields = nFields + 1 && go to next field ...
- enddo && asc(field....
- endscan && scan of database record by record ...
-
- use && close database
-
- RETURN
- *-- EoP: ScanMemo
-
- PROCEDURE Cut
- *-------------------------------------------------------------------------------
- *-- Programmer..: Michael B. Carlisle (Borland)
- *-- Date........: 01/xx/1992
- *-- Notes.......: This retrieves information from the field the user has
- *-- currently selected and stores the information into a
- *-- memory variable titled CLIPBOARD. The field itself is
- *-- then cleared. CLIPBOARD should be declared public.
- *-- This routine is taken from TECHNOTES.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: do CUT with "<cFld>","<cScrType>"
- *-- Example.....: on key label F6 do CUT with varread(),"READ"
- *-- Returns.....: None
- *-- Parameters..: cFld = Field to 'CUT' the data from.
- *-- cScrType = What screen type? Valid options are BROWSE,
- *-- EDIT and READ.
- *-------------------------------------------------------------------------------
-
- parameters cFld,cScrType
-
- *-- test field type, ignore if field is memo
- clipboard = iif(type(cFld) = "D",;
- right(dtos(&cFld),4)+substr(dtos(&cFld),3,2),;
- iif(type(cFld) = "L",iif(&cFld,"T","F"),;
- iif(type(cFld)="M","",&cFld)))
-
- *-- if field type is Numeric or Float, convert to string.
- if type(cFld) $ "NF"
- clipboard = ltrim(str(int(fixed(&cFld)),20)+;
- right(str(fixed(&cFld) - int(fixed(&cFld)),20,18,19))
- do while val(right(clipboard,1)) = 0 .and. .not. right(clipboard,1)="."
- clipboard = left(clipboard,len(clipboard)-1)
- enddo
- endif
-
- *-- Ring bell if field is MEMO, otherwise, clear the field
- if type(cFld) = "M"
- ?? chr(7)
- else
- *-- do to difference in function of the HOME keys in BROWSE mode,
- *-- Ctrl-Home has to be used in BROWSE
- if upper(cScrType) = "BROWS"
- keyboard chr(29)+chr(25) && go to beginning of field and clear
- else
- keyboard chr(26)+chr(25) && ditto
- endif
- endif
-
- RETURN
- *-- EoP: Cut
-
- PROCEDURE Copy
- *-------------------------------------------------------------------------------
- *-- Programmer..: Michael B. Carlisle (Borland)
- *-- Date........: 01/xx/1992
- *-- Notes.......: This retrieves information from the field the user has
- *-- currently selected and stores the information into a
- *-- memory variable titled CLIPBOARD. The field itself is
- *-- left 'as is' (unlike CUT). CLIPBOARD should be declared
- *-- public. This routine is taken from TECHNOTES.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: do COPY with "<cFld>"
- *-- Example.....: on key label F8 do COPY with varread()
- *-- Returns.....: None
- *-- Parameters..: cFld = Field to 'COPY' the data from.
- *-------------------------------------------------------------------------------
-
- parameters cFld
-
- *-- test field type, ignore if field is memo
- clipboard = iif(type(cFld) = "D",;
- right(dtos(&cFld),4)+substr(dtos(&cFld),3,2),;
- iif(type(cFld) = "L",iif(&cFld,"T","F"),;
- iif(type(cFld)="M","",&cFld)))
-
- *-- if field type is Numeric or Float, convert to string.
- if type(cFld) $ "NF"
- clipboard = ltrim(str(int(fixed(&cFld)),20)+;
- right(str(fixed(&cFld) - int(fixed(&cFld)),20,18,19))
- do while val(right(clipboard,1)) = 0 .and. .not. right(clipboard,1)="."
- clipboard = left(clipboard,len(clipboard)-1)
- enddo
- endif
-
- *-- Ring bell if field is MEMO, otherwise, clear the field
- if type(cFld) = "M"
- ?? chr(7)
- endif
-
- RETURN
- *-- EoP: Copy
-
- PROCEDURE Paste
- *-------------------------------------------------------------------------------
- *-- Programmer..: Michael B. Carlisle (Borland)
- *-- Date........: 01/xx/1992
- *-- Notes.......: Paste writes out the contents of the CLIPBOARD (public)
- *-- memvar to the currently selected field. Because all values
- *-- are converted to strings when stored into the CLIPBOARD,
- *-- Paste is able to write values from one field type to another
- *-- (such as numeric to character, date to numeric, etc.).
- *-- This routine is taken from TECHNOTES.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: do PASTE with "<cFld>","<cScrType>"
- *-- Example.....: on key label F7 do PASTE with varread(), "READ"
- *-- Returns.....: None
- *-- Parameters..: cFld = Field to 'PASTE' the data in CLIPBOARD to.
- *-- cScrType = What screen type? Valid options are BROWSE,
- *-- EDIT and READ.
- *-------------------------------------------------------------------------------
-
- parameters cFld, cScrType
-
- *-- ring bell if field is MEMO, otherwise, fill the field.
- if type(cFld) = "M"
- ?? chr(7)
- else
- *-- due to difference in function of HOME in the BROWSE mode,
- *-- Ctrl-Home has to be used in BROWSE.
- if upper(cScrType) = "BROWSE"
- keyboard chr(29)+chr(25)+ClipBoard && go to beginning of field,
- && and clear, putting contents
- && of clipboard in.
- else
- keyboard chr(26)+chr(25)+ClipBoard
- endif
- endif && type ...
-
- RETURN
- *-- EoP: Paste
-
- FUNCTION Blanker
- *-------------------------------------------------------------------------------
- *-- Programmer..: Curt Schroeders (Borland Tech Support)
- *-- Date........: 07/01/1992
- *-- Notes.......: Used to BLANK a numeric field once the user presses a key
- *-- that may be used IN a numeric field.
- *-- SIDE EFFECT -- if you use this function, the original value
- *-- in the field will be erased ... this does not allow editing
- *-- of the numeric field.
- *-- Written for.: dBASE IV, 1.5 (should work in 1.1)
- *-- Rev. History: 07/13/1992 -- Ken Mayer -- added '-' and '.' as valid
- *-- characters in list ...
- *-- Usage.......: Blanker()
- *-- Example.....: @5,10 get Salary when blanker()
- *-- Returns.....: Logical
- *-- Parameters..: None
- *-------------------------------------------------------------------------------
-
- private nX
-
- *-- get keystroke from user
- nX = inkey(0)
-
- *-- if nX is in list
- if chr(nX) $ "0123456789-."
- keyboard "{CTRL-Y}" && blank out field
- endif
- keyboard chr(nX) && return this character ...
-
- RETURN .t.
- *-- EoF: Blanker()
-
- FUNCTION GetRange
- *-------------------------------------------------------------------------------
- *-- Programmer..: Joey D. Carroll (JOEY)
- *-- Date........: 10/12/1992
- *-- Notes.......: A function to get a range for use with 'set key to range x,y'
- *-- or 'set filter to'. Works with character, numeric, float,
- *-- and date types.
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: 11/08/1992 Changed to protect active windows.
- *-- Added SHADOW (JOEY)
- *-- 11/09/1992 Added (optional) cStyle parameter (JOEY)
- *-- Calls.......: CENTER, SHADOW
- *-- Called by...: Any
- *-- Usage.......: ?? GetRange(<cText>,<xPara1>,<xPara2>,<cPicture>, ;
- *-- <nStartRow>,<cColor>[,cStyle])
- *-- Example.....: * get a range for a date, dbf in use is ordered by TRANDATE
- *-- dDate1={}
- *-- dDate2={}
- *-- ?? GetRange("Enter date range for your report",dDate1,dDate2,;
- *-- "",10,"w+/r,n/w,w+/gb")
- *-- * now use values determined by getrange()
- *-- set key to range dDate1,dDate2
- *-- go top
- *-- * if the dbf is not indexed on a date or if you just =have=
- *-- * to use a filter e.g.--
- *-- * set filter to Transdate >= dDate1 .and. Transdate<=dDate2
- *-- report form <yourreport> to print
- *-- Returns.....: .t. if correct type parameters, otherwise .f.
- *-- Parameters..: cText = Message to center in window. May be nul "".
- *-- xPara1 = First elemement of the 'key'.
- *-- The 'width' of the character 'get' is
- *-- determined by len(xPara1).
- *-- The 'width' of the date 'get' is determined
- *-- by set("century").
- *-- xPara2 = Second element of the 'key'.
- *-- cPicture = Used to determine 'width' and format of
- *-- numeric or float 'get', and the format
- *-- of the character 'get'. May be nul "".
- *-- Ignored if xPara1 is date type.
- *-- nStartRow = Row to place top of window.
- *-- Message row (24) is protected.
- *-- cColor = Colors to be used ("Normal/HiLite/Box")
- *-- (may be nul "", in order to use the
- *-- default colors of window/screen)
- *-- cStyle = "H" = horizontal "V" = verticle (may be
- *-- omitted or ""/nul to default to "H" --
- *-- =Very= long parameters default to "V")
- *-------------------------------------------------------------------------------
-
- parameters cText,xPara1,xPara2,cPicture,nStartRow,cColor,cStyle
- private cTalk,cColor2,nSayLen,nPictLen,wPrevWind,nEndRow
-
- *-- is a window active
- wPrevWind = window()
- activate screen
-
- *-- in case no color is passed, this will prevent bomb
- cColor2 = iif(isblank(cColor),"","color &cColor")
-
- *-- calculate window size based on parameters
- do case
- case type("xPara1") = "C"
- *-- xPara1,xPara2 should initialized with space(len(alias->fieldname))
- *-- or space(len(var))
- nPictLen = 2 * len(xPara1)
- case type("xPara1") = "N" .or. type("xPara1") = "F"
- *-- gotta have a picture to define window width
- cPicture = iif(isblank(cPicture),"9999999999",cPicture)
- nPictLen = 2 * len(cPicture)
- case type("xPara1")="D"
- nPictLen = 2 * (iif(set("CENTURY")="OFF",8,10))
- otherwise
- if .not. isblank(wPrevWind)
- activate window &wPrevWind
- endif
- ?? chr(7)
- RETURN .f. && stupid!
- endcase
-
- cText = " "+cText && don't jamb against box edge
-
- *-- is the window width going to be wider than 75 cols, OR was "V"
- *-- passed in the cStyle param? If so, use verticle style
-
- nSayLen = len("From: ") + len("To: ")
- nWindWidth = nSayLen + nPictLen + 7
- *-- if len(cText) > nWindWidth, fix it
- nWindWidth = max(nWindWidth,len(cText) + 3)
-
- if nWindWidth <= 76 .and. (pcount() < 7 .or. upper(cStyle) = "H")
- cStyle = "H" && make it so
- nStartRow = min(nStartRow,16) && protect row 24 even from shadow
- nStartCol = (80-nWindWidth) / 2 && center the window
- nEndRow = nStartRow + 6
-
- define window wGetRange from nStartRow,nStartCol to nEndRow, ;
- nStartCol+nWindWidth &cColor2. double
- else
- *-- wants verticle style or params are too wide for horizontal
- *-- so do some re-figgering
- cStyle = "V" && make it so
- nStartRow = min(nStartRow,14) && protect row 24 even from shadow
- nEndRow = nStartRow + 8
- *-- recalc window width for this style
- nSayLen = len("From: ")
- nPictLen = nPictLen / 2 && doubled for horz., so cut by 1/2
- nWindWidth = nSayLen + nPictLen + 7
- *-- if len(cText) > nWindWidth, fix it
- nWindWidth = max(nWindWidth,len(cText) + 3)
- nStartCol = (80-nWindWidth) / 2 && center the window
-
- define window wGetRange from nStartRow,nStartCol to nEndRow, ;
- nStartCol+nWindWidth &cColor2. double
- endif
-
- save screen to sGetRange
-
- *-- now USE what you've done so far
- do shadow with nStartRow,nStartCol,nEndRow,nStartCol+nWindWidth
- activate window wGetRange
- do center with 1,nWindWidth - 2,"",cText
-
- @ 2,0 to 2,nWindWidth - 2
- @ 3,2 say 'From:' get xPara1 picture cPicture
-
- if cStyle = "H"
- @ 3,(nWindWidth- 2 ) - (len("To: ")) - (nPictLen/2) - 1 ;
- say 'To:' get xPara2 picture cPicture
- else
- @ 5,4 say 'To:' get xPara2 picture cPicture
- endif
-
- read
-
- *-- clean up your doin's
- deactivate window wGetRange
- restore screen from sGetRange
- release screen sGetRange
- release window wGetRange
-
- if .not. isblank(wPrevWind)
- activate window &wPrevWind
- endif
-
- RETURN .t.
- *-- EoF: GetRange()
-
- FUNCTION FldWidth
- *-------------------------------------------------------------------------------
- *-- Programmer..: Kenneth Chan [HazMatZak] (CIS: 71542,2712)
- *-- Date........: 01/28/1993
- *-- Notes.......: Returns the width of a field, without having to read the
- *-- .DBF structure into a file and use low-level functions ...
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: FldWidth(<nField>)
- *-- Example.....: ?FldWidth(3)
- *-- Returns.....: Numeric value
- *-- Parameters..: nField = field number in file structure
- *-------------------------------------------------------------------------------
-
- parameters nField
- private nReturn, cFldType, cFldName
-
- cFldName = field(nField) && get the field name
- cFldType = type(cFldName) && get the type ...
- do case
- case cFldType = "L"
- nReturn = 1
- case cFldType = "D"
- nReturn = 8
- case cFldType = "C"
- nReturn = len(&cFldName.)
- case cFldType $ "NF"
- nReturn = len(transform(&cFldName.,"@L"))
- otherwise
- nReturn = 0
- endcase
-
- RETURN nReturn
- *-- EoF: FldWidth()
-
- FUNCTION FldDec
- *-------------------------------------------------------------------------------
- *-- Programmer..: Kenneth Chan [HazMatZak] (CIS: 71542,2712)
- *-- Date........: 01/28/1993
- *-- Notes.......: Returns the number of decimal places of a numeric field.
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: FldDec(<nField>)
- *-- Example.....: ?FldDec(3)
- *-- Returns.....: Numeric value, 0 if non-numeric field type
- *-- Parameters..: nField = field number in file structure
- *-------------------------------------------------------------------------------
-
- parameters nField
- private nReturn, cTemplate, cFldName
-
- cFldName = field(nField)
- if type(cFldName) $ "NF" && if it's numeric/float type
- cTemplate = transform(&cFldName.,"@L")
- nReturn = at(".",cTemplate)
- if nReturn > 0
- nReturn = len(cTemplate) - nReturn
- endif
- else
- nReturn = 0
- endif
-
- RETURN nReturn
- *-- EoF: FldDec()
-
- *-------------------------------------------------------------------------------
- *-- EoP: FIELDS.PRG
- *-------------------------------------------------------------------------------